home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / tclx7.5a- / tclx7 / usr / local / tclX / 7.5a-a2 / tcl.tlib < prev    next >
Encoding:
Text File  |  1995-11-14  |  36.7 KB  |  1,466 lines
  1.  
  2. #@package: TclX-ArrayProcedures for_array_keys
  3.  
  4. proc for_array_keys {varName arrayName codeFragment} {
  5.     upvar $varName enumVar $arrayName enumArray
  6.  
  7.     if ![info exists enumArray] {
  8.     error "\"$arrayName\" isn't an array"
  9.     }
  10.  
  11.     set code 0
  12.     set result {}
  13.     set searchId [array startsearch enumArray]
  14.     while {[array anymore enumArray $searchId]} {
  15.     set enumVar [array nextelement enumArray $searchId]
  16.         set code [catch {uplevel 1 $codeFragment} result]
  17.         if {$code != 0 && $code != 4} break
  18.     }
  19.     array donesearch enumArray $searchId
  20.  
  21.     if {$code == 0 || $code == 3 || $code == 4} {
  22.         return $result
  23.     }
  24.     if {$code == 1} {
  25.         global errorCode errorInfo
  26.         return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
  27.     }
  28.     return -code $code $result
  29. }
  30.  
  31. #@package: TclX-Compatibility assign_fields server_open cexpand
  32.  
  33. proc assign_fields {list args} {
  34.     if [lempty $args] {
  35.         return
  36.     }
  37.     return [uplevel lassign [list $list] $args]
  38. }
  39.  
  40. proc server_open args {
  41.     set cmd server_connect
  42.  
  43.     set buffered 1
  44.     while {[string match -* [lindex $args 0]]} {
  45.         set opt [lvarpop args]
  46.         if [cequal $opt -buf] {
  47.             set buffered 1
  48.         } elseif  [cequal $opt -nobuf] {
  49.             set buffered 0
  50.         }
  51.         lappend cmd $opt
  52.     }
  53.     if $buffered {
  54.         lappend cmd -twoids
  55.     }
  56.     set cmd [concat $cmd $args]
  57.  
  58.     uplevel $cmd
  59. }
  60.  
  61. proc cexpand str {subst -nocommands -novariables $str}
  62.  
  63. #@package: TclX-convertlib convert_lib
  64.  
  65.  
  66. proc tclx:ParseTclIndex {tclIndex fileTblVar ignore} {
  67.     upvar $fileTblVar fileTbl
  68.     set allOK 1
  69.  
  70.     # Open and validate the file.
  71.  
  72.     set tclIndexFH [open $tclIndex r]
  73.     set hdr [gets $tclIndexFH]
  74.     if {$hdr != "# Tcl autoload index file, version 2.0"} {
  75.         error "can only convert version 2.0 Tcl auto-load files"
  76.     }
  77.     set dir [file dirname $tclIndex]  ;# Expected by the script.
  78.     eval [read $tclIndexFH]
  79.     close $tclIndexFH
  80.  
  81.     foreach procName [array names auto_index] {
  82.         if ![string match "source *" $auto_index($procName)] {
  83.             puts stderr "WARNING: Can't convert load command for \"$procName\": $auto_index($procName)"
  84.             set allOK 0
  85.             continue
  86.         }
  87.         set filePath [lindex $auto_index($procName) 1]
  88.         set fileName [file tail $filePath] 
  89.         if {[lsearch $ignore $fileName] >= 0} continue
  90.  
  91.         lappend fileTbl($filePath) $procName
  92.     }
  93.     if ![info exists fileTbl] {
  94.         error "no entries could be converted in $tclIndex"
  95.     }
  96.     return $allOK
  97. }
  98.  
  99.  
  100. proc convert_lib {tclIndex packageLib {ignore {}}} {
  101.     global tclx_library
  102.     source $tclx_library/buildidx.tcl
  103.  
  104.     if {[file tail $tclIndex] != "tclIndex"} {
  105.         error "Tail file name must be `tclIndex': $tclIndex"}
  106.     if ![file readable $tclIndex] {
  107.         error "File not readable: $tclIndex"
  108.     }
  109.  
  110.     # Expand to root relative file name.
  111.  
  112.     set tclIndex [glob $tclIndex]
  113.     if ![string match "/*" $tclIndex] {
  114.         set tclIndex "[pwd]/$tclIndex"
  115.     }
  116.  
  117.     # Parse the file.
  118.  
  119.     set allOK [tclx:ParseTclIndex $tclIndex fileTbl $ignore]
  120.  
  121.     # Generate the .tlib package names with contain the directory and
  122.     # file name, less any extensions.
  123.  
  124.     if {[file extension $packageLib] != ".tlib"} {
  125.         append packageLib ".tlib"
  126.     }
  127.     set libFH [open $packageLib w]
  128.  
  129.     foreach srcFile [array names fileTbl] {
  130.         set pkgName [file tail [file dirname $srcFile]]/[file tail [file root $srcFile]]
  131.         set srcFH [open $srcFile r]
  132.         puts $libFH "#@package: $pkgName $fileTbl($srcFile)\n"
  133.         copyfile $srcFH $libFH
  134.         close $srcFH
  135.     }
  136.     close $libFH
  137.     buildpackageindex $packageLib
  138.     if !$allOK {
  139.         error "*** Not all entries converted, but library generated"
  140.     }
  141. }
  142.  
  143. #@package: TclX-developer_utils saveprocs edprocs
  144.  
  145. proc saveprocs {fileName args} {
  146.     set fp [open $fileName w]
  147.     puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
  148.     puts $fp [eval "showproc $args"]
  149.     close $fp
  150. }
  151.  
  152. proc edprocs {args} {
  153.     global env
  154.  
  155.     set tmpFilename /tmp/tcldev.[id process]
  156.  
  157.     set fp [open $tmpFilename w]
  158.     puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
  159.     puts $fp [eval "showproc $args"]
  160.     close $fp
  161.  
  162.     if [info exists env(EDITOR)] {
  163.         set editor $env(EDITOR)
  164.     } else {
  165.     set editor vi
  166.     }
  167.  
  168.     set startMtime [file mtime $tmpFilename]
  169.     system "$editor $tmpFilename"
  170.  
  171.     if {[file mtime $tmpFilename] != $startMtime} {
  172.     source $tmpFilename
  173.     echo "Procedures were reloaded."
  174.     } else {
  175.     echo "No changes were made."
  176.     }
  177.     unlink $tmpFilename
  178.     return
  179. }
  180.  
  181. #@package: TclX-forfile for_file
  182.  
  183. proc for_file {var filename cmd} {
  184.     upvar $var line
  185.     set fp [open $filename r]
  186.     set code 0
  187.     set result {}
  188.     while {[gets $fp line] >= 0} {
  189.         set code [catch {uplevel 1 $cmd} result]
  190.         if {$code != 0 && $code != 4} break
  191.     }
  192.     close $fp
  193.  
  194.     if {$code == 0 || $code == 3 || $code == 4} {
  195.         return $result
  196.     }
  197.     if {$code == 1} {
  198.         global errorCode errorInfo
  199.         return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
  200.     }
  201.     return -code $code $result
  202. }
  203.  
  204. #@package: TclX-globrecur recursive_glob
  205.  
  206. proc recursive_glob {dirlist globlist} {
  207.     set result {}
  208.     set recurse {}
  209.     foreach dir $dirlist {
  210.         if ![file isdirectory $dir] {
  211.             error "\"$dir\" is not a directory"
  212.         }
  213.         foreach pattern $globlist {
  214.             set result [concat $result [glob -nocomplain -- $dir/$pattern]]
  215.         }
  216.         foreach file [readdir $dir] {
  217.             set file $dir/$file
  218.             if [file isdirectory $file] {
  219.                 set fileTail [file tail $file]
  220.                 if {!(($fileTail == ".") || ($fileTail == ".."))} {
  221.                     lappend recurse $file
  222.                 }
  223.             }
  224.         }
  225.     }
  226.     if ![lempty $recurse] {
  227.         set result [concat $result [recursive_glob $recurse $globlist]]
  228.     }
  229.     return $result
  230. }
  231.  
  232. #@package: TclX-forrecur for_recursive_glob
  233.  
  234. proc for_recursive_glob {var dirlist globlist cmd {depth 1}} {
  235.     upvar $depth $var myVar
  236.     set recurse {}
  237.     foreach dir $dirlist {
  238.         if ![file isdirectory $dir] {
  239.             error "\"$dir\" is not a directory"
  240.         }
  241.         set code 0
  242.         set result {}
  243.         foreach pattern $globlist {
  244.             foreach file [glob -nocomplain -- $dir/$pattern] {
  245.                 set myVar $file
  246.                 set code [catch {uplevel $depth $cmd} result]
  247.                 if {$code != 0 && $code != 4} break
  248.             }
  249.             if {$code != 0 && $code != 4} break
  250.         }
  251.         if {$code != 0 && $code != 4} {
  252.             if {$code == 3} {
  253.                 return $result
  254.             }
  255.             if {$code == 1} {
  256.                 global errorCode errorInfo
  257.                 return -code $code -errorcode $errorCode \
  258.                         -errorinfo $errorInfo $result
  259.             }
  260.             return -code $code $result
  261.         }
  262.  
  263.         foreach file [readdir $dir] {
  264.             set file $dir/$file
  265.             if [file isdirectory $file] {
  266.                 set fileTail [file tail $file]
  267.                 if {!(($fileTail == ".") || ($fileTail == ".."))} {
  268.                     lappend recurse $file
  269.                 }
  270.             }
  271.         }
  272.     }
  273.     if ![lempty $recurse] {
  274.         return [for_recursive_glob $var $recurse $globlist $cmd \
  275.                     [expr {$depth + 1}]]
  276.     }
  277.     return {}
  278. }
  279.  
  280. #@package: TclX-help help helpcd helppwd apropos
  281.  
  282.  
  283. proc help:RootDirs {} {
  284.     global auto_path
  285.     set roots {}
  286.     foreach dir $auto_path {
  287.         if [file isdirectory $dir/help] {
  288.             lappend roots $dir/help
  289.         }
  290.     }
  291.     return $roots
  292. }
  293.  
  294.  
  295. proc help:FlattenPath pathName {
  296.     set newPath {}
  297.     foreach element [split $pathName /] {
  298.         if {"$element" == "." || [lempty $element]} continue
  299.  
  300.         if {"$element" == ".."} {
  301.             if {[llength [join $newPath /]] == 0} {
  302.                 error "Help: name goes above subject directory root" {} \
  303.                     [list TCLXHELP NAMEABOVEROOT $pathName]
  304.             }
  305.             lvarpop newPath [expr [llength $newPath]-1]
  306.             continue
  307.         }
  308.         lappend newPath $element
  309.     }
  310.     set newPath [join $newPath /]
  311.  
  312.     # Take care of the case where we started with something line "/" or "/."
  313.  
  314.     if {("$newPath" == "") && [string match "/*" $pathName]} {
  315.         set newPath "/"
  316.     }
  317.         
  318.     return $newPath
  319. }
  320.  
  321.  
  322. proc help:ConvertPath pathName {
  323.     global TCLXENV
  324.  
  325.     if {![string match "/*" $pathName]} {
  326.         if {"$TCLXENV(help:curSubject)" == "/"} {
  327.             set pathName "/$pathName"
  328.         } else {
  329.             set pathName "$TCLXENV(help:curSubject)/$pathName"
  330.         }
  331.     }
  332.     set pathName [help:FlattenPath $pathName]
  333.  
  334.     # If the virtual root is specified, return a list of directories.
  335.  
  336.     if {$pathName == "/"} {
  337.         return [help:RootDirs]
  338.     }
  339.  
  340.     # Not the virtual root find the first match.
  341.  
  342.     foreach dir [help:RootDirs] {
  343.         if [file readable $dir/$pathName] {
  344.             return [list $dir/$pathName]
  345.         }
  346.     }
  347.     error "\"$pathName\" does not exist" {} \
  348.         [list TCLXHELP NOEXIST $pathName]
  349. }
  350.  
  351.  
  352. proc help:RelativePath pathName {
  353.     foreach dir [help:RootDirs] {
  354.         if {[csubstr $pathName 0 [clength $dir]] == $dir} {
  355.             set name [csubstr $pathName [clength $dir] end]
  356.             if {$name == ""} {set name /}
  357.             return $name
  358.         }
  359.     }
  360.     if ![info exists found] {
  361.         error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR]
  362.     }
  363. }
  364.  
  365.  
  366. proc help:ListSubject {pathName pathList subjectsVar pagesVar} {
  367.     upvar $subjectsVar subjects $pagesVar pages
  368.  
  369.     set subjects {}
  370.     set pages {}
  371.     set foundDir 0
  372.     foreach dir $pathList {
  373.         if ![file isdirectory $dir] continue
  374.         set foundDir 1
  375.         foreach file [glob -nocomplain $dir/*] {
  376.             if [string match *.brf $file] continue
  377.             if [file isdirectory $file] {
  378.                 lappend subjects [file tail $file]/
  379.             } else {
  380.                 lappend pages [file tail $file]
  381.             }
  382.         }
  383.     }
  384.     if !$foundDir {
  385.         if [cequal $pathName /] {
  386.             global auto_path
  387.             error "no \"help\" directories found on auto_path ($auto_path)" {} \
  388.                 [list TCLXHELP NOHELPDIRS]
  389.         } else {
  390.             error "\"$pathName\" is not a subject" {} \
  391.                 [list TCLXHELP NOTSUBJECT $pathName]
  392.         }
  393.     }
  394.     set subjects [lsort $subjects]
  395.     set pages [lsort $pages]
  396.     return {}
  397. }
  398.  
  399.  
  400. proc help:Display line {
  401.     global TCLXENV
  402.     if {$TCLXENV(help:lineCnt) >= 23} {
  403.         set TCLXENV(help:lineCnt) 0
  404.         puts stdout ":" nonewline
  405.         flush stdout
  406.         gets stdin response
  407.         if {![lempty $response]} {
  408.             return 0}
  409.     }
  410.     puts stdout $line
  411.     incr TCLXENV(help:lineCnt)
  412. }
  413.  
  414.  
  415. proc help:DisplayPage filePath {
  416.  
  417.     set inFH [open $filePath r]
  418.     while {[gets $inFH fileBuf] >= 0} {
  419.         if {![help:Display $fileBuf]} {
  420.             break}
  421.     }
  422.     close $inFH
  423. }    
  424.  
  425.  
  426. proc help:DisplayColumns {nameList} {
  427.     set count 0
  428.     set outLine ""
  429.     foreach name $nameList {
  430.         if {$count == 0} {
  431.             append outLine "   "}
  432.         append outLine $name
  433.         if {[incr count] < 4} {
  434.             set padLen [expr 17-[clength $name]]
  435.             if {$padLen < 3} {
  436.                set padLen 3}
  437.             append outLine [replicate " " $padLen]
  438.         } else {
  439.            if {![help:Display $outLine]} {
  440.                return}
  441.            set outLine ""
  442.            set count 0
  443.         }
  444.     }
  445.     if {$count != 0} {
  446.         help:Display [string trimright $outLine]}
  447.     return
  448. }
  449.  
  450.  
  451. proc help:HelpOnHelp {} {
  452.     set helpPage [lindex [help:ConvertPath /help] 0]
  453.     if [lempty $helpPage] {
  454.         error "No help page on help found" {} \
  455.             [list TCLXHELP NOHELPPAGE]
  456.     }
  457.     help:DisplayPage $helpPage
  458. }
  459.  
  460.  
  461. proc help {{what {}}} {
  462.     global TCLXENV
  463.  
  464.     set TCLXENV(help:lineCnt) 0
  465.  
  466.     # Special case "help help", so we can get it at any level.
  467.  
  468.     if {($what == "help") || ($what == "?")} {
  469.         help:HelpOnHelp
  470.         return
  471.     }
  472.  
  473.     set pathList [help:ConvertPath $what]
  474.     if [file isfile [lindex $pathList 0]] {
  475.         help:DisplayPage [lindex $pathList 0]
  476.         return
  477.     }
  478.  
  479.     help:ListSubject $what $pathList subjects pages
  480.     set relativeDir [help:RelativePath [lindex $pathList 0]]
  481.  
  482.     if {[llength $subjects] != 0} {
  483.         help:Display "\nSubjects available in $relativeDir:"
  484.         help:DisplayColumns $subjects
  485.     }
  486.     if {[llength $pages] != 0} {
  487.         help:Display "\nHelp pages available in $relativeDir:"
  488.         help:DisplayColumns $pages
  489.     }
  490. }
  491.  
  492.  
  493.  
  494. proc helpcd {{dir /}} {
  495.     global TCLXENV
  496.  
  497.     set pathName [lindex [help:ConvertPath $dir] 0]
  498.  
  499.     if {![file isdirectory $pathName]} {
  500.         error "\"$dir\" is not a subject" \
  501.             [list TCLXHELP NOTSUBJECT $dir]
  502.     }
  503.  
  504.     set TCLXENV(help:curSubject) [help:RelativePath $pathName]
  505.     return
  506. }
  507.  
  508.  
  509. proc helppwd {} {
  510.         global TCLXENV
  511.         echo "Current help subject: $TCLXENV(help:curSubject)"
  512. }
  513.  
  514.  
  515. proc apropos {regexp} {
  516.     global TCLXENV
  517.  
  518.     set TCLXENV(help:lineCnt) 0
  519.  
  520.     set ch [scancontext create]
  521.     scanmatch -nocase $ch $regexp {
  522.         set path [lindex $matchInfo(line) 0]
  523.         set desc [lrange $matchInfo(line) 1 end]
  524.         if {![help:Display [format "%s - %s" $path $desc]]} {
  525.             set stop 1
  526.             return}
  527.     }
  528.     set stop 0
  529.     foreach dir [help:RootDirs] {
  530.         foreach brief [glob -nocomplain $dir/*.brf] {
  531.             set briefFH [open $brief]
  532.             scanfile $ch $briefFH
  533.             close $briefFH
  534.             if $stop break
  535.         }
  536.         if $stop break
  537.     }
  538.     scancontext delete $ch
  539. }
  540.  
  541. global TCLXENV
  542.  
  543. set TCLXENV(help:curSubject) "/"
  544.  
  545. #@package: TclX-profrep profrep
  546.  
  547. proc profrep:sortcmp {key1 key2} {
  548.     upvar profData profData keyIndex keyIndex
  549.     
  550.     set val1 [lindex $profData($key1) $keyIndex]
  551.     set val2 [lindex $profData($key2) $keyIndex]
  552.  
  553.     if {$val1 < $val2} {
  554.         return -1
  555.     }
  556.     if {$val1 > $val2} {
  557.         return 1
  558.     }
  559.     return 0
  560. }
  561.  
  562. proc profrep:sort {profDataVar sortKey} {
  563.     upvar $profDataVar profData
  564.  
  565.     case $sortKey {
  566.         {calls} {set keyIndex 0}
  567.         {real}  {set keyIndex 1}
  568.         {cpu}   {set keyIndex 2}
  569.         default {
  570.             error "Expected a sort type of: `calls', `cpu' or ` real'"
  571.         }
  572.     }
  573.  
  574.     return [lsort -integer -decreasing -command profrep:sortcmp \
  575.             [array names profData]]
  576. }
  577.  
  578. proc profrep:print {profDataVar sortedProcList outFile userTitle} {
  579.     upvar $profDataVar profData
  580.     
  581.     set maxNameLen 0
  582.     foreach procStack [array names profData] {
  583.         foreach procName $procStack {
  584.             set maxNameLen [max $maxNameLen [clength $procName]]
  585.         }
  586.     }
  587.  
  588.     if {$outFile == ""} {
  589.         set outFH stdout
  590.     } else {
  591.         set outFH [open $outFile w]
  592.     }
  593.  
  594.     # Output a header.
  595.  
  596.     set stackTitle "Procedure Call Stack"
  597.     set maxNameLen [max [expr $maxNameLen+6] [expr [clength $stackTitle]+4]]
  598.     set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
  599.                     "Calls" "Real Time" "CPU Time"]
  600.     if {$userTitle != ""} {
  601.         puts $outFH [replicate - [clength $hdr]]
  602.         puts $outFH $userTitle
  603.     }
  604.     puts $outFH [replicate - [clength $hdr]]
  605.     puts $outFH $hdr
  606.     puts $outFH [replicate - [clength $hdr]]
  607.  
  608.     # Output the data in sorted order.
  609.  
  610.     foreach procStack $sortedProcList {
  611.         set data $profData($procStack)
  612.         puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" \
  613.                             [lvarpop procStack] \
  614.                             [lindex $data 0] [lindex $data 1] [lindex $data 2]]
  615.         foreach procName $procStack {
  616.             if {$procName == "<global>"} break
  617.             puts $outFH "    $procName"
  618.         }
  619.     }
  620.     if {$outFile != ""} {
  621.         close $outFH
  622.     }
  623. }
  624.  
  625.  
  626. proc profrep {profDataVar sortKey {outFile {}} {userTitle {}}} {
  627.     upvar $profDataVar profData
  628.  
  629.     set sortedProcList [profrep:sort profData $sortKey]
  630.     profrep:print profData $sortedProcList $outFile $userTitle
  631.  
  632. }
  633.  
  634. #@package: TclX-directory_stack pushd popd dirs
  635.  
  636. global TCLXENV(dirPushList)
  637.  
  638. set TCLXENV(dirPushList) ""
  639.  
  640. proc pushd {{new ""}} {
  641.     global TCLXENV
  642.  
  643.     set current [pwd]
  644.     if {[clength $new] > 0} {
  645.         set dirs [glob -nocomplain $new]
  646.         set count [llength $dirs]
  647.         if {$count == 0} {
  648.             error "no such directory: $new"
  649.         } elseif {$count != 1} {
  650.             error "ambiguous directory: $new: [join $directories ", "]"
  651.         }
  652.         cd [lindex $dirs 0]
  653.         lvarpush TCLXENV(dirPushList) $current
  654.     } else {
  655.         if [lempty $TCLXENV(dirPushList)] {
  656.             error "directory stack empty"
  657.         }
  658.         cd [lindex $TCLXENV(dirPushList) 0]
  659.         lvarpop TCLXENV(dirPushList)
  660.         lvarpush TCLXENV(dirPushList) $current
  661.     }
  662.     return [pwd]
  663. }
  664.  
  665. proc popd {} {
  666.     global TCLXENV
  667.  
  668.     if [lempty $TCLXENV(dirPushList)] {
  669.         error "directory stack empty"
  670.     }
  671.     cd [lvarpop TCLXENV(dirPushList)]
  672.     return [pwd]
  673. }
  674.  
  675. proc dirs {} { 
  676.     global TCLXENV
  677.     return [concat [list [pwd]] $TCLXENV(dirPushList)]
  678. }
  679.  
  680. #@package: TclX-set_functions union intersect intersect3 lrmdups
  681.  
  682. proc union {lista listb} {
  683.     return [lrmdups [concat $lista $listb]]
  684. }
  685.  
  686. proc lrmdups list {
  687.     if [lempty $list] {
  688.         return {}
  689.     }
  690.     set list [lsort $list]
  691.     set last [lvarpop list]
  692.     lappend result $last
  693.     foreach element $list {
  694.     if ![cequal $last $element] {
  695.         lappend result $element
  696.         set last $element
  697.     }
  698.     }
  699.     return $result
  700. }
  701.  
  702.  
  703. proc intersect3 {list1 list2} {
  704.     set list1Result ""
  705.     set list2Result ""
  706.     set intersectList ""
  707.  
  708.     set list1 [lrmdups $list1]
  709.     set list2 [lrmdups $list2]
  710.  
  711.     while {1} {
  712.         if [lempty $list1] {
  713.             if ![lempty $list2] {
  714.                 set list2Result [concat $list2Result $list2]
  715.             }
  716.             break
  717.         }
  718.         if [lempty $list2] {
  719.         set list1Result [concat $list1Result $list1]
  720.             break
  721.         }
  722.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  723.  
  724.         if {$compareResult < 0} {
  725.             lappend list1Result [lvarpop list1]
  726.             continue
  727.         }
  728.         if {$compareResult > 0} {
  729.             lappend list2Result [lvarpop list2]
  730.             continue
  731.         }
  732.         lappend intersectList [lvarpop list1]
  733.         lvarpop list2
  734.     }
  735.     return [list $list1Result $intersectList $list2Result]
  736. }
  737.  
  738. proc intersect {list1 list2} {
  739.     set intersectList ""
  740.  
  741.     set list1 [lsort $list1]
  742.     set list2 [lsort $list2]
  743.  
  744.     while {1} {
  745.         if {[lempty $list1] || [lempty $list2]} break
  746.  
  747.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  748.  
  749.         if {$compareResult < 0} {
  750.             lvarpop list1
  751.             continue
  752.         }
  753.  
  754.         if {$compareResult > 0} {
  755.             lvarpop list2
  756.             continue
  757.         }
  758.  
  759.         lappend intersectList [lvarpop list1]
  760.         lvarpop list2
  761.     }
  762.     return $intersectList
  763. }
  764.  
  765.  
  766.  
  767. #@package: TclX-showproc showproc
  768.  
  769. proc showproc args {
  770.     if [lempty $args] {
  771.         set args [info procs]
  772.     }
  773.     set out {}
  774.  
  775.     foreach procname $args {
  776.         if [lempty [info procs $procname]] {
  777.             auto_load $procname
  778.         }
  779.         set arglist [info args $procname]
  780.         set nargs {}
  781.         while {[llength $arglist] > 0} {
  782.             set varg [lvarpop arglist 0]
  783.             if [info default $procname $varg defarg] {
  784.                 lappend nargs [list $varg $defarg]
  785.             } else {
  786.                 lappend nargs $varg
  787.             }
  788.         }
  789.         append out "proc $procname [list $nargs] \{[info body $procname]\}\n"
  790.     }
  791.     return $out
  792. }
  793.  
  794. #@package: TclX-stringfile_functions read_file write_file
  795.  
  796. proc read_file {fileName args} {
  797.     if {$fileName == "-nonewline"} {
  798.         set flag $fileName
  799.         set fileName [lvarpop args]
  800.     } else {
  801.         set flag {}
  802.     }
  803.     set fp [open $fileName]
  804.     set stat [catch {
  805.         eval read $flag $fp $args
  806.     } result]
  807.     close $fp
  808.     if {$stat != 0} {
  809.         global errorInfo errorCode
  810.         error $result $errorInfo $errorCode
  811.     }
  812.     return $result
  813. } 
  814.  
  815. proc write_file {fileName args} {
  816.     set fp [open $fileName w]
  817.     
  818.     set stat [catch {
  819.         foreach string $args {
  820.             puts $fp $string
  821.         }
  822.     } result]
  823.     close $fp
  824.     if {$stat != 0} {
  825.         global errorInfo errorCode
  826.         error $result $errorInfo $errorCode
  827.     }
  828. }
  829.  
  830.  
  831. #@package: TclX-libraries searchpath auto_load_file
  832.  
  833. proc searchpath {pathlist file} {
  834.     foreach dir $pathlist {
  835.         if {$dir == ""} {set dir .}
  836.         if {[catch {file exists $dir/$file} result] == 0 && $result}  {
  837.             return $dir/$file
  838.         }
  839.     }
  840.     return {}
  841. }
  842.  
  843. proc auto_load_file {name} {
  844.     global auto_path errorCode
  845.     if {[string first / $name] >= 0} {
  846.         return  [uplevel 1 source $name]
  847.     }
  848.     set where [searchpath $auto_path $name]
  849.     if [lempty $where] {
  850.         error "couldn't find $name in any directory in auto_path"
  851.     }
  852.     uplevel 1 source $where
  853. }
  854.  
  855. #@package: TclX-lib-list auto_packages auto_commands
  856.  
  857.  
  858. proc auto_packages {{option {}}} {
  859.     global auto_pkg_index
  860.  
  861.     auto_load  ;# Make sure all indexes are loaded.
  862.     if ![info exists auto_pkg_index] {
  863.         return {}
  864.     }
  865.     
  866.     set packList [array names auto_pkg_index] 
  867.     if [lempty $option] {
  868.         return $packList
  869.     }
  870.  
  871.     if {$option != "-files"} {
  872.         error "Unknow option \"$option\", expected \"-files\""
  873.     }
  874.     set locList {}
  875.     foreach pack $packList {
  876.         lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]]
  877.     }
  878.     return $locList
  879. }
  880.  
  881.  
  882. proc auto_commands {{option {}}} {
  883.     global auto_index
  884.  
  885.     auto_load  ;# Make sure all indexes are loaded.
  886.     if ![info exists auto_index] {
  887.         return {}
  888.     }
  889.     
  890.     set cmdList [array names auto_index] 
  891.     if [lempty $option] {
  892.         return $cmdList
  893.     }
  894.  
  895.     if {$option != "-loaders"} {
  896.         error "Unknow option \"$option\", expected \"-loaders\""
  897.     }
  898.     set loadList {}
  899.     foreach cmd $cmdList {
  900.         lappend loadList [list $cmd $auto_index($cmd)]
  901.     }
  902.     return $loadList
  903. }
  904.  
  905. #@package: TclX-ucblib auto_reset auto_mkindex
  906.  
  907.  
  908. proc auto_reset {} {
  909.     global auto_execs auto_index auto_oldpath
  910.     foreach p [info procs] {
  911.     if {[info exists auto_index($p)] && ($p != "unknown")
  912.         && ![string match auto_* $p]} {
  913.         rename $p {}
  914.     }
  915.     }
  916.     catch {unset auto_execs}
  917.     catch {unset auto_index}
  918.     catch {unset auto_oldpath}
  919.     # *** TclX ***
  920.     global auto_pkg_index tclx_library
  921.     catch {unset auto_pkg_index}
  922.     set auto_index(buildpackageindex) {source $tclx_library/buildidx.tcl}
  923.     return
  924. }
  925.  
  926.  
  927. proc auto_mkindex {dir args} {
  928.     global errorCode errorInfo
  929.     set oldDir [pwd]
  930.     cd $dir
  931.     set dir [pwd]
  932.     append index "# Tcl autoload index file, version 2.0\n"
  933.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  934.     append index "# and sourced to set up indexing information for one or\n"
  935.     append index "# more commands.  Typically each line is a command that\n"
  936.     append index "# sets an element in the auto_index array, where the\n"
  937.     append index "# element name is the name of a command and the value is\n"
  938.     append index "# a script that loads the command.\n\n"
  939.     foreach file [eval glob $args] {
  940.     set f ""
  941.     set error [catch {
  942.         set f [open $file]
  943.         while {[gets $f line] >= 0} {
  944.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  945.             append index "set [list auto_index($procName)]"
  946.             append index " \"source \$dir/$file\"\n"
  947.         }
  948.         }
  949.         close $f
  950.     } msg]
  951.     if $error {
  952.         set code $errorCode
  953.         set info $errorInfo
  954.         catch {close $f}
  955.         cd $oldDir
  956.         error $msg $info $code
  957.     }
  958.     }
  959.     set f [open tclIndex w]
  960.     puts $f $index nonewline
  961.     close $f
  962.     cd $oldDir
  963. }
  964.  
  965. #@package: TclX-fmath acos asin atan ceil cos cosh exp fabs floor log log10 \
  966.            sin sinh sqrt tan tanh fmod pow atan2 abs double int round
  967.  
  968. proc acos  x {uplevel [list expr acos($x)]}
  969. proc asin  x {uplevel [list expr asin($x)]}
  970. proc atan  x {uplevel [list expr atan($x)]}
  971. proc ceil  x {uplevel [list expr ceil($x)]}
  972. proc cos   x {uplevel [list expr cos($x)]}
  973. proc cosh  x {uplevel [list expr cosh($x)]}
  974. proc exp   x {uplevel [list expr exp($x)]}
  975. proc fabs  x {uplevel [list expr abs($x)]}
  976. proc floor x {uplevel [list expr floor($x)]}
  977. proc log   x {uplevel [list expr log($x)]}
  978. proc log10 x {uplevel [list expr log10($x)]}
  979. proc sin   x {uplevel [list expr sin($x)]}
  980. proc sinh  x {uplevel [list expr sinh($x)]}
  981. proc sqrt  x {uplevel [list expr sqrt($x)]}
  982. proc tan   x {uplevel [list expr tan($x)]}
  983. proc tanh  x {uplevel [list expr tanh($x)]}
  984.  
  985. proc fmod {x n} {uplevel [list expr fmod($x,$n)]}
  986. proc pow {x n} {uplevel [list expr pow($x,$n)]}
  987.  
  988.  
  989. proc atan2  x {uplevel [list expr atan2($x)]}
  990. proc abs    x {uplevel [list expr abs($x)]}
  991. proc double x {uplevel [list expr double($x)]}
  992. proc int    x {uplevel [list expr int($x)]}
  993. proc round  x {uplevel [list expr round($x)]}
  994.  
  995.  
  996. #@package: TclX-shell tclx_unknown2 auto_execok
  997.  
  998.  
  999. proc tclx_unknown2 cmd {
  1000.     global tcl_interactive auto_noexec
  1001.  
  1002.     set name [lindex $cmd 0]
  1003.  
  1004.     if ![info exists auto_noexec] {
  1005.         if [auto_execok $name] {
  1006.             if {!$tcl_interactive || [info level] > 2 || [info script] != ""} {
  1007.                 return [list return -code error "Auto execution of Unix commands only supported as interactive commands.\nUse \"exec\" to execute \"$name\""]
  1008.             }
  1009.             return [list eval [list system $cmd] {;} concat]
  1010.         }
  1011.     }
  1012.  
  1013.     if {!$tcl_interactive || ([info level] > 2) || [info script] != ""} {
  1014.         return [list  return -code error "invalid command name \"$name\""]
  1015.     }
  1016.  
  1017.     # csh-style redo.
  1018.  
  1019.     if {([info level] == 2) && ([info script] == "")} {
  1020.         if {$name == "!!"} {
  1021.             return {history redo}
  1022.         }
  1023.         if [regexp {^!(.+)$} $name dummy event] {
  1024.             return [list history redo $event]
  1025.         }
  1026.         if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  1027.             return [list history substitute $old $new]
  1028.         }
  1029.         set cmds [info commands $name*]
  1030.         if {[llength $cmds] == 1} {
  1031.             return [lreplace $cmd 0 0 $cmds]
  1032.         }
  1033.         if {[llength $cmds] != 0} {
  1034.             if {$name == ""} {
  1035.                 return [list return -code error "empty command name \"\""]
  1036.             } else {
  1037.                 return [list return -code error \
  1038.                         "ambiguous command name \"$name\": [lsort $cmds]"]
  1039.             }
  1040.         }
  1041.     }
  1042.     return [list return -code error "invalid command name \"$name\""]
  1043. }
  1044.  
  1045.  
  1046.  
  1047. proc auto_execok name {
  1048.     global auto_execs env
  1049.  
  1050.     if [info exists auto_execs($name)] {
  1051.         return $auto_execs($name)
  1052.     }
  1053.     set auto_execs($name) 0
  1054.     if {[string first / $name] >= 0} {
  1055.     if {[file executable $name] && ![file isdirectory $name]} {
  1056.         set auto_execs($name) 1
  1057.     }
  1058.     return $auto_execs($name)
  1059.     }
  1060.     foreach dir [split $env(PATH) :] {
  1061.         if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  1062.             set auto_execs($name) 1
  1063.             return 1
  1064.         }
  1065.     }
  1066.     return 0
  1067. }
  1068.  
  1069. #@package: TclX-buildhelp buildhelp
  1070.  
  1071. proc TruncFileName {pathName} {
  1072.     global truncFileNames
  1073.  
  1074.     if {!$truncFileNames} {
  1075.         return $pathName}
  1076.     set fileName [file tail $pathName]
  1077.     if {"[crange $fileName 0 3]" == "Tcl_"} {
  1078.         set fileName [crange $fileName 4 end]}
  1079.     set fileName [crange $fileName 0 13]
  1080.     return "[file dirname $pathName]/$fileName"
  1081. }
  1082.  
  1083.  
  1084. proc EnsureDirs {filePath} {
  1085.     set dirPath [file dirname $filePath]
  1086.     if [file exists $dirPath] return
  1087.     foreach dir [split $dirPath /] {
  1088.         lappend dirList $dir
  1089.         set partPath [join $dirList /]
  1090.         if [file exists $partPath] continue
  1091.  
  1092.         mkdir $partPath
  1093.         chmod u=rwx,go=rx $partPath
  1094.     }
  1095. }
  1096.  
  1097.  
  1098. proc CreateFilterNroffManPageContext {} {
  1099.     global filterNroffManPageContext
  1100.  
  1101.     set filterNroffManPageContext [scancontext create]
  1102.  
  1103.     # On finding a page header, drop the previous line (which is
  1104.     # the page footer). Also deleting the blank lines followin
  1105.     # the last line on the previous page.
  1106.  
  1107.     scanmatch $filterNroffManPageContext {@@@BUILDHELP@@@} {
  1108.         catch {unset prev2Blanks}
  1109.         catch {unset prev1Line}
  1110.         catch {unset prev1Blanks}
  1111.         set nukeBlanks {}
  1112.     }
  1113.  
  1114.     # Save blank lines
  1115.  
  1116.     scanmatch $filterNroffManPageContext {$^} {
  1117.         if ![info exists nukeBlanks] {
  1118.             append prev1Blanks \n
  1119.         }
  1120.     }
  1121.  
  1122.     # Non-blank line, save it.  Output the 2nd previous line if necessary.
  1123.  
  1124.     scanmatch $filterNroffManPageContext {
  1125.         catch {unset nukeBlanks}
  1126.         if [info exists prev2Line] {
  1127.             puts $outFH $prev2Line
  1128.             unset prev2Line
  1129.         }
  1130.         if [info exists prev2Blanks] {
  1131.             puts $outFH $prev2Blanks nonewline
  1132.             unset prev2Blanks
  1133.         }
  1134.         if [info exists prev1Line] {
  1135.             set prev2Line $prev1Line
  1136.         }
  1137.         set prev1Line $matchInfo(line)
  1138.         if [info exists prev1Blanks] {
  1139.             set prev2Blanks $prev1Blanks
  1140.             unset prev1Blanks
  1141.         }
  1142.     }
  1143. }
  1144.  
  1145.  
  1146. proc FilterNroffManPage {inFH outFH} {
  1147.     global filterNroffManPageContext
  1148.  
  1149.     if ![info exists filterNroffManPageContext] {
  1150.         CreateFilterNroffManPageContext
  1151.     }
  1152.  
  1153.     scanfile $filterNroffManPageContext $inFH
  1154.  
  1155.     if [info exists prev2Line] {
  1156.         puts $outFH $prev2Line
  1157.     }
  1158. }
  1159.  
  1160.  
  1161. proc CreateExtractNroffHeaderContext {} {
  1162.     global extractNroffHeaderContext
  1163.  
  1164.     set extractNroffHeaderContext [scancontext create]
  1165.  
  1166.     scanmatch $extractNroffHeaderContext {'\\"@endheader[     ]*$} {
  1167.         break
  1168.     }
  1169.     scanmatch $extractNroffHeaderContext {'\\"@:} {
  1170.         append nroffHeader "[crange $matchInfo(line) 5 end]\n"
  1171.     }
  1172.     scanmatch $extractNroffHeaderContext {
  1173.         append nroffHeader "$matchInfo(line)\n"
  1174.     }
  1175. }
  1176.  
  1177.  
  1178. proc ExtractNroffHeader {manPageFH} {
  1179.     global extractNroffHeaderContext nroffHeader
  1180.  
  1181.     if ![info exists extractNroffHeaderContext] {
  1182.         CreateExtractNroffHeaderContext
  1183.     }
  1184.     scanfile $extractNroffHeaderContext $manPageFH
  1185. }
  1186.  
  1187.  
  1188.  
  1189. proc CreateExtractNroffHelpContext {} {
  1190.     global extractNroffHelpContext
  1191.  
  1192.     set extractNroffHelpContext [scancontext create]
  1193.  
  1194.     scanmatch $extractNroffHelpContext {^'\\"@endhelp[     ]*$} {
  1195.         break
  1196.     }
  1197.  
  1198.     scanmatch $extractNroffHelpContext {^'\\"@brief:} {
  1199.         if $foundBrief {
  1200.             error {Duplicate "@brief:" entry}
  1201.         }
  1202.         set foundBrief 1
  1203.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 11 end]"
  1204.         continue
  1205.     }
  1206.  
  1207.     scanmatch $extractNroffHelpContext {^'\\"@:} {
  1208.         puts $nroffFH  [csubstr $matchInfo(line) 5 end]
  1209.         continue
  1210.     }
  1211.     scanmatch $extractNroffHelpContext {^'\\"@help:} {
  1212.         error {"@help" found within another help section"}
  1213.     }
  1214.     scanmatch $extractNroffHelpContext {
  1215.         puts $nroffFH $matchInfo(line)
  1216.     }
  1217. }
  1218.  
  1219.  
  1220. proc ExtractNroffHelp {manPageFH manLine} {
  1221.     global helpDir nroffHeader briefHelpFH colArgs
  1222.     global extractNroffHelpContext
  1223.  
  1224.     if ![info exists extractNroffHelpContext] {
  1225.         CreateExtractNroffHelpContext
  1226.     }
  1227.  
  1228.     set helpName [string trim [csubstr $manLine 9 end]]
  1229.     set helpFile [TruncFileName "$helpDir/$helpName"]
  1230.     if [file exists $helpFile] {
  1231.         error "Help file already exists: $helpFile"
  1232.     }
  1233.     EnsureDirs $helpFile
  1234.  
  1235.     set tmpFile "[file dirname $helpFile]/tmp.[id process]"
  1236.  
  1237.     echo "    creating help file $helpName"
  1238.  
  1239.     set nroffFH [open "| nroff -man | col $colArgs > $tmpFile" w]
  1240.  
  1241.     puts $nroffFH {.TH @@@BUILDHELP@@@ 1}
  1242.  
  1243.     set foundBrief 0
  1244.     scanfile $extractNroffHelpContext $manPageFH
  1245.  
  1246.     # Close returns an error on if anything comes back on stderr, even if
  1247.     # its a warning.  Output errors and continue.
  1248.  
  1249.     set stat [catch {
  1250.         close $nroffFH
  1251.     } msg]
  1252.     if $stat {
  1253.         puts stderr "nroff: $msg"
  1254.     }
  1255.  
  1256.     set tmpFH [open $tmpFile r]
  1257.     set helpFH [open $helpFile w]
  1258.  
  1259.     FilterNroffManPage $tmpFH $helpFH
  1260.  
  1261.     close $tmpFH
  1262.     close $helpFH
  1263.  
  1264.     unlink $tmpFile
  1265.     chmod a-w,a+r $helpFile
  1266. }
  1267.  
  1268.  
  1269. proc CreateExtractScriptHelpContext {} {
  1270.     global extractScriptHelpContext
  1271.  
  1272.     set extractScriptHelpContext [scancontext create]
  1273.  
  1274.     scanmatch $extractScriptHelpContext {^#@endhelp[     ]*$} {
  1275.         break
  1276.     }
  1277.  
  1278.     scanmatch $extractScriptHelpContext {^#@brief:} {
  1279.         if $foundBrief {
  1280.             error {Duplicate "@brief" entry}
  1281.         }
  1282.         set foundBrief 1
  1283.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 9 end]"
  1284.         continue
  1285.     }
  1286.  
  1287.     scanmatch $extractScriptHelpContext {^#@help:} {
  1288.         error {"@help" found within another help section"}
  1289.     }
  1290.  
  1291.     scanmatch $extractScriptHelpContext {^#$} {
  1292.         puts $helpFH ""
  1293.     }
  1294.  
  1295.     scanmatch $extractScriptHelpContext {
  1296.         if {[clength $matchInfo(line)] > 1} {
  1297.             puts $helpFH " [csubstr $matchInfo(line) 1 end]"
  1298.         } else {
  1299.             puts $helpFH $matchInfo(line)
  1300.         }
  1301.     }
  1302. }
  1303.  
  1304.  
  1305. proc ExtractScriptHelp {scriptPageFH scriptLine} {
  1306.     global helpDir briefHelpFH
  1307.     global extractScriptHelpContext
  1308.  
  1309.     if ![info exists extractScriptHelpContext] {
  1310.         CreateExtractScriptHelpContext
  1311.     }
  1312.  
  1313.     set helpName [string trim [csubstr $scriptLine 7 end]]
  1314.     set helpFile "$helpDir/$helpName"
  1315.     if {[file exists $helpFile]} {
  1316.         error "Help file already exists: $helpFile"
  1317.     }
  1318.     EnsureDirs $helpFile
  1319.  
  1320.     echo "    creating help file $helpName"
  1321.  
  1322.     set helpFH [open $helpFile w]
  1323.  
  1324.     set foundBrief 0
  1325.     scanfile $extractScriptHelpContext $scriptPageFH
  1326.  
  1327.     close $helpFH
  1328.     chmod a-w,a+r $helpFile
  1329. }
  1330.  
  1331.  
  1332. proc ProcessNroffFile {pathName} {
  1333.    global nroffScanCT scriptScanCT nroffHeader
  1334.  
  1335.    set fileName [file tail $pathName]
  1336.  
  1337.    set nroffHeader {}
  1338.    set manPageFH [open $pathName r]
  1339.    set matchInfo(fileName) [file tail $pathName]
  1340.  
  1341.    echo "    scanning $pathName"
  1342.  
  1343.    scanfile $nroffScanCT $manPageFH
  1344.  
  1345.    close $manPageFH
  1346. }
  1347.  
  1348.  
  1349. proc ProcessTclScript {pathName} {
  1350.    global scriptScanCT nroffHeader
  1351.  
  1352.    set scriptFH [open "$pathName" r]
  1353.    set matchInfo(fileName) [file tail $pathName]
  1354.  
  1355.    echo "    scanning $pathName"
  1356.    scanfile $scriptScanCT $scriptFH
  1357.  
  1358.    close $scriptFH
  1359. }
  1360.  
  1361.  
  1362. proc buildhelp {helpDirPath briefFile sourceFiles} {
  1363.     global helpDir truncFileNames nroffScanCT
  1364.     global scriptScanCT briefHelpFH colArgs
  1365.  
  1366.     echo ""
  1367.     echo "Begin building help tree"
  1368.  
  1369.     # Determine version of col command to use (no -x on BSD)
  1370.     if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
  1371.         set colArgs {-b}
  1372.     } else {
  1373.         set colArgs {-bx}
  1374.     }
  1375.     set helpDir $helpDirPath
  1376.     if {![file exists $helpDir]} {
  1377.         mkdir $helpDir
  1378.     }
  1379.  
  1380.     if {![file isdirectory $helpDir]} {
  1381.         error [concat "$helpDir is not a directory or does not exist. "  
  1382.                       "This should be the help root directory"]
  1383.     }
  1384.         
  1385.     set status [catch {set tmpFH [open $helpDir/AVeryVeryBigFileName w]}]
  1386.     if {$status != 0} {
  1387.         set truncFileNames 1
  1388.     } else {
  1389.         close $tmpFH
  1390.         unlink $helpDir/AVeryVeryBigFileName
  1391.         set truncFileNames 0
  1392.     }
  1393.  
  1394.     set nroffScanCT [scancontext create]
  1395.  
  1396.     scanmatch $nroffScanCT {'\\"@help:} {
  1397.         ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
  1398.         continue
  1399.     }
  1400.  
  1401.     scanmatch $nroffScanCT {^'\\"@header} {
  1402.         ExtractNroffHeader $matchInfo(handle)
  1403.         continue
  1404.     }
  1405.     scanmatch $nroffScanCT {^'\\"@endhelp} {
  1406.         error [concat {@endhelp" without corresponding "@help:"} \
  1407.                  ", offset = $matchInfo(offset)"]
  1408.     }
  1409.     scanmatch $nroffScanCT {^'\\"@brief} {
  1410.         error [concat {"@brief" without corresponding "@help:"} \
  1411.                  ", offset = $matchInfo(offset)"]
  1412.     }
  1413.  
  1414.     set scriptScanCT [scancontext create]
  1415.     scanmatch $scriptScanCT {^#@help:} {
  1416.         ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
  1417.     }
  1418.  
  1419.     if {[file extension $briefFile] != ".brf"} {
  1420.         error "Brief file \"$briefFile\" must have an extension \".brf\""
  1421.     }
  1422.     if [file exists $helpDir/$briefFile] {
  1423.         error "Brief file \"$helpDir/$briefFile\" already exists"
  1424.     }
  1425.     set briefHelpFH [open "|sort > $helpDir/$briefFile" w]
  1426.  
  1427.     foreach manFile [glob $sourceFiles] {
  1428.         set ext [file extension $manFile]
  1429.         if {$ext == ".tcl" || $ext == ".tlib"} {
  1430.             set status [catch {ProcessTclScript $manFile} msg]
  1431.         } else {
  1432.             set status [catch {ProcessNroffFile $manFile} msg]
  1433.         }
  1434.         if {$status != 0} {
  1435.             global errorInfo errorCode
  1436.             error "Error extracting help from: $manFile" $errorInfo $errorCode
  1437.         }
  1438.     }
  1439.  
  1440.     close $briefHelpFH
  1441.     chmod a-w,a+r $helpDir/$briefFile
  1442.     echo "Completed extraction of help files"
  1443. }
  1444.  
  1445.  
  1446. #@package: Tcl-parray parray
  1447.  
  1448.  
  1449. proc parray {a {pattern *}} {
  1450.     upvar 1 $a array
  1451.     if ![array exists array] {
  1452.     error "\"$a\" isn't an array"
  1453.     }
  1454.     set maxl 0
  1455.     foreach name [lsort [array names array $pattern]] {
  1456.     if {[string length $name] > $maxl} {
  1457.         set maxl [string length $name]
  1458.     }
  1459.     }
  1460.     set maxl [expr {$maxl + [string length $a] + 2}]
  1461.     foreach name [lsort [array names array $pattern]] {
  1462.     set nameString [format %s(%s) $a $name]
  1463.     puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
  1464.     }
  1465. }
  1466.